home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
protobnu.lqr
/
PROTOCOL.PAS
next >
Wrap
Pascal/Delphi Source File
|
1985-06-13
|
21KB
|
718 lines
{***************
**
** This module implements the B-Protocol Functions for terminal.pas.
** The only procedures this routine requires that are not located here
** are send and cgetc. These routines should be as follows:
**
** procedure send(ch : integer);
** (*This procedure sends the character who's ordinal value is CH to the
** async port*)
**
** function cgetc(wait_time : integer) : integer;
** (*This function waits approximately WAIT_TIME seconds for a character
** at the async port. If no character is received, -1 is returned,
** otherwise the ordinal value of the received character is returned*)
**
** These definitions should be sufficient to implement B-Protocol in a
** pascal program. The routine DO_TRANSFER should be invoked whenever a
** ENQ (ascii value 5) is received from the host. It returns TRUE if the
** operation it performs is successful.
**
** If you have any questions contact me, Jim Nutt, at either 76044,1155 or
** 71076,1434 on CIS, or at FIDOnet Node 452.
****************}
function do_transfer : boolean;
const xmt_size = 511;
rcv_size = 512;
max_errors = 10;
{ Sender actions }
s_send_packet = 0;
s_get_dle = 1;
s_get_num = 2;
s_get_seq = 3;
s_get_data = 4;
s_get_checksum = 5;
s_timed_out = 6;
s_send_nak = 7;
{ Receiver actions }
r_get_dle = 0;
r_get_b = 1;
r_get_seq = 2;
r_get_data = 3;
r_get_checksum = 4;
r_send_nak = 5;
r_send_ack = 6;
{Other Constants}
xmt_col = 50;
rcv_col = 36;
xon = 17;
xoff = 19;
dle = 16;
etx = 03;
nak = 21;
enq = 05;
wack = 59;
type lstr = string[255];
buffertype = array[0..520] of byte;
bytefile = file of byte;
var
timer,
r_size, { size of receiver buffer }
checksum,
seq_num,
ch : integer; { current character }
xoff_flag,
timed_out, { we timed out before receiving character }
masked : boolean;
{ true if ctrl character was 'masked' }
s_buffer : buffertype;
r_buffer : buffertype;
filename : lstr; { pathname }
i, n : integer;
dummy : boolean;
s_counter : byte;
r_counter : byte;
procedure send_masked_byte(ch : integer);
begin
if ch < 32
then
begin
send(dle);
send(ch + ord('@'));
end
else
send(ch);
s_counter := (s_counter + 1) mod 64;
if s_counter = 0 then write('.');
end;
procedure send_ack;
begin
write('!');
send(dle);
send(seq_num + ord('0'));
end;
procedure send_nak;
begin
write('?');
send(nak);
end;
procedure send_enq;
begin
write('¿');
send(enq);
end;
function read_byte : boolean;
begin
timed_out := false;
ch := cgetc(timer);
if ch < 0 then
begin
read_byte := false;
exit;
end;
r_counter := (r_counter + 1) mod 64;
if r_counter = 0 then write('+');
read_byte := true;
end;
function read_masked_byte : boolean;
begin
masked := false;
if (read_byte = false)
then begin
read_masked_byte := false;
exit;
end;
if (ch = dle)
then
begin
if (read_byte = false)
then begin
read_masked_byte := false;
exit;
end;
ch := ch and $1f;
masked := true;
end;
read_masked_byte := true;
end;
procedure do_checksum(ch : integer);
begin
checksum := checksum shl 1;
if (checksum > 255)
then checksum := (checksum and $ff) + 1;
checksum := checksum + ch;
if (checksum > 255)
then checksum := (checksum and $ff) + 1;
end;
function send_packet(size: integer) : boolean;
var
action,
errors,
next_seq,
block_num,
i : integer;
sent_enq : boolean;
begin
next_seq := (seq_num + 1) mod 10;
errors := 0;
sent_enq := false;
action := s_send_packet;
writeln;
while true do
case (action) of
s_send_packet: begin
checksum := 0;
send(dle);
send(ord('B'));
send(next_seq + ord('0'));
do_checksum(next_seq + ord('0'));
for i := 0 to size do
begin
send_masked_byte(s_buffer[i]);
do_checksum(s_buffer[i]);
end;
send(etx);
do_checksum(etx);
send_masked_byte(checksum);
action := s_get_dle;
end;
s_get_dle: begin
timer := 30;
if (read_byte = false)
then action := s_timed_out
else if (ch = dle)
then action := s_get_num
else if (ch = nak)
then
begin
errors := errors + 1;
if (errors > max_errors)
then begin
send_packet := false;
exit;
end;
action := s_send_packet;
end
else if (ch = etx)
then action := s_send_nak;
end;
s_get_num: begin
timer := 30;
if (read_byte = false)
then action := s_timed_out
else if (ch >= ord('0')) and (ch <= ord('9'))
then
begin
if (ch - ord('0') = seq_num)
then
if (sent_enq)
then action := s_send_packet
else action := s_get_dle
else
if (ch - ord('0') = next_seq)
then
begin
seq_num := next_seq;
send_packet := true;
exit
end
else
if (errors = 0)
then action := s_send_packet
else action := s_get_dle;
end
else if (ch = nak)
then action := s_send_packet
else if (ch = wack)
then
begin
timer := timer + 10;
action := s_get_dle;
end
else if (ch = ord('B'))
then action := s_get_seq
else if (ch = etx)
then action := s_send_nak
else action := s_get_dle;
end;
s_get_seq: begin
timer := 10;
if (read_byte = false)
then action := s_send_nak
else
begin
checksum := 0;
block_num := ch - ord('0');
do_checksum(ch);
i := 0;
action := s_get_data;
end;
end;
s_get_data: begin
timer := 10;
if (read_masked_byte = false)
then action := s_send_nak
else if ((ch = etx) and not masked)
then
begin
do_checksum(etx);
action := s_get_checksum;
end
else
begin
r_buffer[i] := ch;
i := i + 1;
do_checksum(ch);
end;
end;
s_get_checksum: begin
timer := 10;
if (read_masked_byte = false)
then action := s_send_nak
else if (ch <> checksum)
then action := s_send_nak
else if (block_num <> (next_seq + 1) mod 10)
then action := s_send_nak
else
begin
seq_num := block_num;
send_ack;
r_size := i;
send_packet := true;
exit;
end;
end;
s_timed_out: begin
errors := errors + 1;
if (errors > 4)
then begin
send_packet := false;
exit;
end;
action := s_get_dle;
end;
s_send_nak: begin
errors := errors + 1;
if (errors > max_errors)
then begin
send_packet := false;
exit;
end;
send_nak;
action := s_get_dle;
end;
end;
end; { Send_Packet }
procedure send_failure(code : char);
var dummy : boolean;
begin
s_buffer[0] := ord('F');
s_buffer[1] := ord(code);
dummy := send_packet(2);
end;
function read_file(var data_file : bytefile; var s_buffer : buffertype;
n, xmt_size : integer) : integer;
var i : integer;
begin
i := n;
while (not eof(data_file)) and (xmt_size > 0) do
begin
read(data_file,s_buffer[i]);
i := i + 1;
xmt_size := xmt_size - 1;
end;
read_file := i - n;
end;
function send_file(name : lstr) : boolean;
var n : integer;
data_file : bytefile;
begin
assign(data_file,name);
{$i-}
reset(data_file);
{$i+}
if (ioresult > 0)
then
begin
send_failure('E');
begin
send_file := false;
exit;
end
end;
repeat
s_buffer[0] := ord('N');
n := read_file(data_file, s_buffer,1, xmt_size);
if (n > 0)
then
begin
if (send_packet(n) = false)
then
begin
begin
send_file := false;
exit;
end
end;
end;
until not (n > 0);
{ Inform host that the file was sent }
s_buffer[0] := ord('T');
s_buffer[1] := ord('C');
if (send_packet(2) = false)
then
begin
begin
send_file := false;
exit;
end
end
else
begin
close(data_file);
send_file := true;
exit;
end;
end; { Send_File }
function read_packet : boolean;
{True if packet is available from host}
var
action,
next_seq,
block_num,
errors,
i : integer;
begin
fillchar(r_buffer,520,0);
next_seq := (seq_num + 1) mod 10;
errors := 0;
action := r_get_dle;
writeln;
while true do
begin
timer := 10;
case (action) of
r_get_dle: begin
if (read_byte = false)
then action := r_send_nak
else if ((ch and$7F) = dle)
then action := r_get_b
else if ((ch and $7F) = enq)
then action := r_send_ack;
end;
r_get_b: begin
if (read_byte = false)
then action := r_send_nak
else if ((ch and $7F) = ord('B'))
then action := r_get_seq
else if (ch = enq)
then action := r_send_ack
else action := r_get_dle;
end;
r_get_seq: begin
if (read_byte = false)
then action := r_send_nak
else if (ch = enq)
then action := r_send_ack
else
begin
checksum := 0;
block_num := ch - ord('0');
do_checksum(ch);
i := 0;
action := r_get_data;
end;
end;
r_get_data: begin
if (read_masked_byte = false)
then action := r_send_nak
else if ((ch = etx) and not masked)
then
begin
do_checksum(etx);
action := r_get_checksum;
end
else
begin
r_buffer[i] := ch;
i := i + 1;
do_checksum(ch);
end;
end;
r_get_checksum: begin
if (read_masked_byte = false)
then action := r_send_nak
else if (ch <> checksum)
then action := r_send_nak
else if (block_num = seq_num)
then
begin
if (r_buffer[0] = ord('F'))
then
begin
seq_num := block_num;
r_size := i;
read_packet := true;
exit;
end
else
action := r_send_ack;
end
else if (block_num <> next_seq)
then action := r_send_nak
else
begin
seq_num := block_num;
r_size := i;
read_packet := true;
exit;
end;
end;
r_send_nak: begin
errors := errors + 1;
if (errors > max_errors)
then begin
read_packet := false;
exit;
end;
send_nak;
action := r_get_dle;
end;
r_send_ack: begin
send_ack;
action := r_get_dle; { wait for the next block }
end;
end;
end;
end; { Read_Packet }
function write_file(var data_file : bytefile; r_buffer : buffertype;
n, size : integer) : integer;
var i : integer;
begin
for i := 1 to size do
write(data_file,r_buffer[n + i - 1]);
end;
function receive_file(name : lstr) : boolean;
var
data_file : bytefile;
status : integer;
begin
assign(data_file,name);
{$i-}
rewrite(data_file);
{$I+}
if (ioresult > 0)
then
begin
send_failure('E');
begin
receive_file := false;
exit;
end
end;
send_ack;
while true do
begin
if (read_packet = true)
then
begin
case chr(r_buffer[0]) of
'N': begin
status := write_file(data_file,r_buffer,1,r_size - 1);
send_ack;
end;
'T': begin
if r_buffer[1] = ord('C') then
begin
writeln('Transfer Complete');
close(data_file);
send_ack;
receive_file := true;
exit;
end;
end;
'F': begin
send_ack;
receive_file := false;
exit;
end;
end;
end;
end;
end; { Receive_File }
begin
xoff_flag := false;
r_counter := 0;
s_counter := 0;
seq_num := 0;
send_ack;
if (read_packet = true)
then
begin
case chr(r_buffer[0]) of
'T': begin
case chr(r_buffer[1]) of
'D' : write('Receiving ');
'U' : write('Sending ');
else
begin
send_failure('N');
exit;
end;
end;
case chr(r_buffer[2]) of
'A': write('ASCII file "');
'B': write('Binary file "');
else
begin
send_failure('N'); { not implemented }
do_transfer := false;
exit;
end;
end;
i := 2;
filename := '';
while (r_buffer[i] <> 0) and (i < r_size) do
begin
i := i + 1;
filename := filename + chr(r_buffer[i]);
end;
writeln(filename,'"');
if (r_buffer[1] = ord('U'))
then
dummy := send_file(filename)
else
dummy := receive_file(filename);
end;
end;
end
else
writeln('Cannot receive initial packet, transfer aborted');
end; { Do_Transfer }
